Module hierarchy: ByteCode and Runtime (cf #13009)

Update haddock submodule

12 files changed, 0 insertions, 7510 deletions

diff --git a/compiler/ghci/ByteCodeAsm.hs b/compiler/ghci/ByteCodeAsm.hs
deleted file mode 100644
index adf701b7e5..0000000000
--- a/compiler/ghci/ByteCodeAsm.hs
+++ /dev/null
@@ -1,566 +0,0 @@
-{-# LANGUAGE BangPatterns, CPP, DeriveFunctor, 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 GHC.StgToCmm.Layout     ( ArgRep(..) )
-import GHC.Runtime.Layout
-import DynFlags
-import Outputable
-import GHC.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        ( genericLength )
-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 { protoBCOName       = nm
-                             , protoBCOInstrs     = instrs
-                             , protoBCOBitmap     = bitmap
-                             , protoBCOBitmapSize = bsize
-                             , protoBCOArity      = arity }) = do
-  -- pass 1: collect up the offsets of the local labels.
-  let asm = mapM_ (assembleI dflags) instrs
-
-      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
-  deriving (Functor)
-
-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
deleted file mode 100644
index 5d5b2990e6..0000000000
--- a/compiler/ghci/ByteCodeGen.hs
+++ /dev/null
@@ -1,2036 +0,0 @@
-{-# LANGUAGE CPP, MagicHash, RecordWildCards, BangPatterns #-}
-{-# LANGUAGE DeriveFunctor #-}
-{-# LANGUAGE GeneralizedNewtypeDeriving #-}
-{-# OPTIONS_GHC -fprof-auto-top #-}
-{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
---
---  (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 GHC.Platform
-import Name
-import MkId
-import Id
-import Var             ( updateVarType )
-import ForeignCall
-import HscTypes
-import CoreUtils
-import CoreSyn
-import PprCore
-import Literal
-import PrimOp
-import CoreFVs
-import Type
-import GHC.Types.RepType
-import DataCon
-import TyCon
-import Util
-import VarSet
-import TysPrim
-import TyCoPpr         ( pprType )
-import ErrUtils
-import Unique
-import FastString
-import Panic
-import GHC.StgToCmm.Closure    ( NonVoid(..), fromNonVoid, nonVoidIds )
-import GHC.StgToCmm.Layout
-import GHC.Runtime.Layout hiding (WordOff, ByteOff, wordsToBytes)
-import GHC.Data.Bitmap
-import OrdList
-import Maybes
-import VarEnv
-
-import Data.List
-import Foreign
-import Control.Monad
-import Data.Char
-
-import UniqSupply
-import Module
-
-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 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  -- list monad
-                (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" FormatByteCode
-           (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 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")
-
-      -- 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 $
-              schemeR [] (invented_name, simpleFreeVars expr)
-
-      when (notNull mallocd)
-           (panic "ByteCodeGen.coreExprToBCOs: missing final emitBc?")
-
-      dumpIfSet_dyn dflags Opt_D_dump_BCOs "Proto-BCOs" FormatByteCode
-         (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. We need only the free variables, not everything in an FVAnn.
--- Historical note: At one point FVAnn was more sophisticated than just
--- a set. Now it isn't. So this function is much simpler. Keeping it around
--- so that if someone changes FVAnn, they will get a nice type error right
--- here.
-simpleFreeVars :: CoreExpr -> AnnExpr Id DVarSet
-simpleFreeVars = freeVars
-
--- -----------------------------------------------------------------------------
--- 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)
-        -- ^ original expression; for debugging only
-   -> 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 -}] (getName 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
--- name of 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.
-        -> (Name, 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)
-
--- If an expression is a lambda (after apply bcView), return the
--- list of arguments to the lambda (in R-to-L order) and the
--- underlying expression
-collect :: AnnExpr Id DVarSet -> ([Var], AnnExpr' Id DVarSet)
-collect (_, e) = go [] e
-  where
-    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]
-    -> Name
-    -> AnnExpr Id DVarSet             -- expression e, for debugging only
-    -> ([Var], AnnExpr' Var DVarSet)  -- result of collect on e
-    -> BcM (ProtoBCO Name)
-schemeR_wrk fvs nm original_body (args, body)
-   = do
-     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 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] -> [Maybe (Id, Word16)]
-getVarOffSets dflags depth env = 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)
-      -- See Note [Not-necessarily-lifted join points], step 3.
-    | isNNLJoinPoint v          = doTailCall d s p (protectNNLJoinPointId v) [AnnVar voidPrimId]
-    | isUnliftedType (idType v) = returnUnboxedAtom d s p e (bcIdArgRep v)
-    | otherwise                 = schemeT d s p e
-
-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
-
-           -- See Note [Not-necessarily-lifted join points], step 2.
-         (xs',rhss') = zipWithAndUnzip protectNNLJoinPointBind xs rhss
-
-         -- Sizes of free vars
-         size_w = trunc16W . idSizeW dflags
-         sizes = map (\rhs_fvs -> sum (map size_w rhs_fvs)) fvss
-
-         -- the arity of each rhs
-         arities = map (genericLength . fst . collect) rhss'
-
-         -- 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 (getName 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))
-
--- Is this Id a not-necessarily-lifted join point?
--- See Note [Not-necessarily-lifted join points], step 1
-isNNLJoinPoint :: Id -> Bool
-isNNLJoinPoint x = isJoinId x &&
-                   Just True /= isLiftedType_maybe (idType x)
-
--- If necessary, modify this Id and body to protect not-necessarily-lifted join points.
--- See Note [Not-necessarily-lifted join points], step 2.
-protectNNLJoinPointBind :: Id -> AnnExpr Id DVarSet -> (Id, AnnExpr Id DVarSet)
-protectNNLJoinPointBind x rhs@(fvs, _)
-  | isNNLJoinPoint x
-  = (protectNNLJoinPointId x, (fvs, AnnLam voidArgId rhs))
-
-  | otherwise
-  = (x, rhs)
-
--- Update an Id's type to take a Void# argument.
--- Precondition: the Id is a not-necessarily-lifted join point.
--- See Note [Not-necessarily-lifted join points]
-protectNNLJoinPointId :: Id -> Id
-protectNNLJoinPointId x
-  = ASSERT( isNNLJoinPoint x )
-    updateVarType (voidPrimTy `mkVisFunTy`) x
-
-{-
-   Ticked Expressions
-   ------------------
-
-  The idea is that the "breakpoint<n,fvs> E" is really just an annotation on
-  the code. When we find such a thing, we pull out the useful information,
-  and then compile the code as if it was just the expression E.
-
-Note [Not-necessarily-lifted join points]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-A join point variable is essentially a goto-label: it is, for example,
-never used as an argument to another function, and it is called only
-in tail position. See Note [Join points] and Note [Invariants on join points],
-both in CoreSyn. Because join points do not compile to true, red-blooded
-variables (with, e.g., registers allocated to them), they are allowed
-to be levity-polymorphic. (See invariant #6 in Note [Invariants on join points]
-in CoreSyn.)
-
-However, in this byte-code generator, join points *are* treated just as
-ordinary variables. There is no check whether a binding is for a join point
-or not; they are all treated uniformly. (Perhaps there is a missed optimization
-opportunity here, but that is beyond the scope of my (Richard E's) Thursday.)
-
-We thus must have *some* strategy for dealing with levity-polymorphic and
-unlifted join points. Levity-polymorphic variables are generally not allowed
-(though levity-polymorphic join points *are*; see Note [Invariants on join points]
-in CoreSyn, point 6), and we don't wish to evaluate unlifted join points eagerly.
-The questionable join points are *not-necessarily-lifted join points*
-(NNLJPs). (Not having such a strategy led to #16509, which panicked in the
-isUnliftedType check in the AnnVar case of schemeE.) Here is the strategy:
-
-1. Detect NNLJPs. This is done in isNNLJoinPoint.
-
-2. When binding an NNLJP, add a `\ (_ :: Void#) ->` to its RHS, and modify the
-   type to tack on a `Void# ->`. (Void# is written voidPrimTy within GHC.)
-   Note that functions are never levity-polymorphic, so this transformation
-   changes an NNLJP to a non-levity-polymorphic join point. This is done
-   in protectNNLJoinPointBind, called from the AnnLet case of schemeE.
-
-3. At an occurrence of an NNLJP, add an application to void# (called voidPrimId),
-   being careful to note the new type of the NNLJP. This is done in the AnnVar
-   case of schemeE, with help from protectNNLJoinPointId.
-
-Here is an example. Suppose we have
-
-  f = \(r :: RuntimeRep) (a :: TYPE r) (x :: T).
-      join j :: a
-           j = error @r @a "bloop"
-      in case x of
-           A -> j
-           B -> j
-           C -> error @r @a "blurp"
-
-Our plan is to behave is if the code was
-
-  f = \(r :: RuntimeRep) (a :: TYPE r) (x :: T).
-      let j :: (Void# -> a)
-          j = \ _ -> error @r @a "bloop"
-      in case x of
-           A -> j void#
-           B -> j void#
-           C -> error @r @a "blurp"
-
-It's a bit hacky, but it works well in practice and is local. I suspect the
-Right Fix is to take advantage of join points as goto-labels.
-
--}
-
--- 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/restore 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 || not (isVoidRep (head a_reps_pushed_r_to_l))
-            = 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 actually 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(case typePrimRep ty of [LiftedRep] -> True; _ -> False) 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)) deriving (Functor)
-
-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 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
deleted file mode 100644
index 9cdd297dbd..0000000000
--- a/compiler/ghci/ByteCodeInstr.hs
+++ /dev/null
@@ -1,373 +0,0 @@
-{-# 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"
-
-import GhcPrelude
-
-import ByteCodeTypes
-import GHCi.RemoteTypes
-import GHCi.FFI (C_ffi_cif)
-import GHC.StgToCmm.Layout     ( ArgRep(..) )
-import PprCore
-import Outputable
-import FastString
-import Name
-import Unique
-import Id
-import CoreSyn
-import Literal
-import DataCon
-import VarSet
-import PrimOp
-import GHC.Runtime.Layout
-
-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, for debugging only
-        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 grow 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 { protoBCOName       = name
-                 , protoBCOInstrs     = instrs
-                 , protoBCOBitmap     = bitmap
-                 , protoBCOBitmapSize = bsize
-                 , protoBCOArity      = arity
-                 , protoBCOExpr       = origin
-                 , protoBCOFFIs       = ffis })
-      = (text "ProtoBCO" <+> ppr name <> char '#' <> int arity
-                <+> text (show ffis) <> colon)
-        $$ nest 3 (case origin of
-                      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
deleted file mode 100644
index 2138482051..0000000000
--- a/compiler/ghci/ByteCodeItbls.hs
+++ /dev/null
@@ -1,76 +0,0 @@
-{-# 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 GHC.Types.RepType
-import GHC.StgToCmm.Layout  ( mkVirtConstrSizes )
-import GHC.StgToCmm.Closure ( 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
deleted file mode 100644
index 9138d1c125..0000000000
--- a/compiler/ghci/ByteCodeLink.hs
+++ /dev/null
@@ -1,184 +0,0 @@
-{-# 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/ByteCodeTypes.hs b/compiler/ghci/ByteCodeTypes.hs
deleted file mode 100644
index 0c0c34ad64..0000000000
--- a/compiler/ghci/ByteCodeTypes.hs
+++ /dev/null
@@ -1,182 +0,0 @@
-{-# LANGUAGE MagicHash, RecordWildCards, GeneralizedNewtypeDeriving #-}
---
---  (c) The University of Glasgow 2002-2006
---
-
--- | Bytecode assembler types
-module ByteCodeTypes
-  ( CompiledByteCode(..), seqCompiledByteCode, FFIInfo(..)
-  , UnlinkedBCO(..), BCOPtr(..), BCONPtr(..)
-  , ItblEnv, ItblPtr(..)
-  , CgBreakInfo(..)
-  , ModBreaks (..), BreakIndex, emptyModBreaks
-  , CCostCentre
-  ) where
-
-import GhcPrelude
-
-import FastString
-import Id
-import Name
-import NameEnv
-import Outputable
-import PrimOp
-import SizedSeq
-import Type
-import SrcLoc
-import GHCi.BreakArray
-import GHCi.RemoteTypes
-import GHCi.FFI
-import Control.DeepSeq
-
-import Foreign
-import Data.Array
-import Data.Array.Base  ( UArray(..) )
-import Data.ByteString (ByteString)
-import Data.IntMap (IntMap)
-import qualified Data.IntMap as IntMap
-import Data.Maybe (catMaybes)
-import GHC.Exts.Heap
-import GHC.Stack.CCS
-
--- -----------------------------------------------------------------------------
--- Compiled Byte Code
-
-data CompiledByteCode = CompiledByteCode
-  { bc_bcos   :: [UnlinkedBCO]  -- Bunch of interpretable bindings
-  , bc_itbls  :: ItblEnv        -- A mapping from DataCons to their itbls
-  , bc_ffis   :: [FFIInfo]      -- ffi blocks we allocated
-  , bc_strs   :: [RemotePtr ()] -- malloc'd strings
-  , bc_breaks :: Maybe ModBreaks -- breakpoint info (Nothing if we're not
-                                 -- creating breakpoints, for some reason)
-  }
-                -- ToDo: we're not tracking strings that we malloc'd
-newtype FFIInfo = FFIInfo (RemotePtr C_ffi_cif)
-  deriving (Show, NFData)
-
-instance Outputable CompiledByteCode where
-  ppr CompiledByteCode{..} = ppr bc_bcos
-
--- Not a real NFData instance, because ModBreaks contains some things
--- we can't rnf
-seqCompiledByteCode :: CompiledByteCode -> ()
-seqCompiledByteCode CompiledByteCode{..} =
-  rnf bc_bcos `seq`
-  rnf (nameEnvElts bc_itbls) `seq`
-  rnf bc_ffis `seq`
-  rnf bc_strs `seq`
-  rnf (fmap seqModBreaks bc_breaks)
-
-type ItblEnv = NameEnv (Name, ItblPtr)
-        -- We need the Name in the range so we know which
-        -- elements to filter out when unloading a module
-
-newtype ItblPtr = ItblPtr (RemotePtr StgInfoTable)
-  deriving (Show, NFData)
-
-data UnlinkedBCO
-   = UnlinkedBCO {
-        unlinkedBCOName   :: !Name,
-        unlinkedBCOArity  :: {-# UNPACK #-} !Int,
-        unlinkedBCOInstrs :: !(UArray Int Word16),      -- insns
-        unlinkedBCOBitmap :: !(UArray Int Word64),      -- bitmap
-        unlinkedBCOLits   :: !(SizedSeq BCONPtr),       -- non-ptrs
-        unlinkedBCOPtrs   :: !(SizedSeq BCOPtr)         -- ptrs
-   }
-
-instance NFData UnlinkedBCO where
-  rnf UnlinkedBCO{..} =
-    rnf unlinkedBCOLits `seq`
-    rnf unlinkedBCOPtrs
-
-data BCOPtr
-  = BCOPtrName   !Name
-  | BCOPtrPrimOp !PrimOp
-  | BCOPtrBCO    !UnlinkedBCO
-  | BCOPtrBreakArray  -- a pointer to this module's BreakArray
-
-instance NFData BCOPtr where
-  rnf (BCOPtrBCO bco) = rnf bco
-  rnf x = x `seq` ()
-
-data BCONPtr
-  = BCONPtrWord  {-# UNPACK #-} !Word
-  | BCONPtrLbl   !FastString
-  | BCONPtrItbl  !Name
-  | BCONPtrStr   !ByteString
-
-instance NFData BCONPtr where
-  rnf x = x `seq` ()
-
--- | Information about a breakpoint that we know at code-generation time
-data CgBreakInfo
-   = CgBreakInfo
-   { cgb_vars   :: [Maybe (Id,Word16)]
-   , cgb_resty  :: Type
-   }
--- See Note [Syncing breakpoint info] in compiler/main/InteractiveEval.hs
-
--- Not a real NFData instance because we can't rnf Id or Type
-seqCgBreakInfo :: CgBreakInfo -> ()
-seqCgBreakInfo CgBreakInfo{..} =
-  rnf (map snd (catMaybes (cgb_vars))) `seq`
-  seqType cgb_resty
-
-instance Outputable UnlinkedBCO where
-   ppr (UnlinkedBCO nm _arity _insns _bitmap lits ptrs)
-      = sep [text "BCO", ppr nm, text "with",
-             ppr (sizeSS lits), text "lits",
-             ppr (sizeSS ptrs), text "ptrs" ]
-
-instance Outputable CgBreakInfo where
-   ppr info = text "CgBreakInfo" <+>
-              parens (ppr (cgb_vars info) <+>
-                      ppr (cgb_resty info))
-
--- -----------------------------------------------------------------------------
--- Breakpoints
-
--- | Breakpoint index
-type BreakIndex = Int
-
--- | C CostCentre type
-data CCostCentre
-
--- | All the information about the breakpoints for a module
-data ModBreaks
-   = ModBreaks
-   { modBreaks_flags :: ForeignRef BreakArray
-        -- ^ The array of flags, one per breakpoint,
-        -- indicating which breakpoints are enabled.
-   , modBreaks_locs :: !(Array BreakIndex SrcSpan)
-        -- ^ An array giving the source span of each breakpoint.
-   , modBreaks_vars :: !(Array BreakIndex [OccName])
-        -- ^ An array giving the names of the free variables at each breakpoint.
-   , modBreaks_decls :: !(Array BreakIndex [String])
-        -- ^ An array giving the names of the declarations enclosing each breakpoint.
-   , modBreaks_ccs :: !(Array BreakIndex (RemotePtr CostCentre))
-        -- ^ Array pointing to cost centre for each breakpoint
-   , modBreaks_breakInfo :: IntMap CgBreakInfo
-        -- ^ info about each breakpoint from the bytecode generator
-   }
-
-seqModBreaks :: ModBreaks -> ()
-seqModBreaks ModBreaks{..} =
-  rnf modBreaks_flags `seq`
-  rnf modBreaks_locs `seq`
-  rnf modBreaks_vars `seq`
-  rnf modBreaks_decls `seq`
-  rnf modBreaks_ccs `seq`
-  rnf (fmap seqCgBreakInfo modBreaks_breakInfo)
-
--- | Construct an empty ModBreaks
-emptyModBreaks :: ModBreaks
-emptyModBreaks = ModBreaks
-   { modBreaks_flags = error "ModBreaks.modBreaks_array not initialised"
-         -- ToDo: can we avoid this?
-   , modBreaks_locs  = array (0,-1) []
-   , modBreaks_vars  = array (0,-1) []
-   , modBreaks_decls = array (0,-1) []
-   , modBreaks_ccs = array (0,-1) []
-   , modBreaks_breakInfo = IntMap.empty
-   }
diff --git a/compiler/ghci/Debugger.hs b/compiler/ghci/Debugger.hs
deleted file mode 100644
index 7bfc4eff4c..0000000000
--- a/compiler/ghci/Debugger.hs
+++ /dev/null
@@ -1,237 +0,0 @@
-{-# 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 GHC.Iface.Syntax ( showToHeader )
-import GHC.Iface.Env    ( 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_ty' = substTy subst (idType id)
-           id'    = id `setIdType` id_ty'
-       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 id_ty' reconstructed_type) of
-         Nothing     -> return (subst, term')
-         Just subst' -> do { dflags <- GHC.getSessionDynFlags
-                           ; liftIO $
-                               dumpIfSet_dyn dflags Opt_D_dump_rtti "RTTI"
-                                 FormatText
-                                 (fsep $ [text "RTTI Improvement for", ppr id,
-                                  text "old substitution:" , ppr subst,
-                                  text "new 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
deleted file mode 100644
index 8795b30973..0000000000
--- a/compiler/ghci/GHCi.hs
+++ /dev/null
@@ -1,667 +0,0 @@
-{-# 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(HAVE_INTERNAL_INTERPRETER)
-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(HAVE_INTERNAL_INTERPRETER)
-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(HAVE_INTERNAL_INTERPRETER)
-   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(HAVE_INTERNAL_INTERPRETER)
-   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(HAVE_INTERNAL_INTERPRETER)
-  | 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
deleted file mode 100644
index 773d396ac9..0000000000
--- a/compiler/ghci/Linker.hs
+++ /dev/null
@@ -1,1707 +0,0 @@
-{-# LANGUAGE CPP, NondecreasingIndentation, TupleSections, RecordWildCards #-}
-{-# LANGUAGE BangPatterns #-}
-
---
---  (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 GHC.Iface.Load
-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 GHC.Platform
-import SysTools
-import FileCleanup
-
--- Standard libraries
-import Control.Monad
-
-import Data.Char (isSpace)
-import Data.IORef
-import Data.List (intercalate, isPrefixOf, isSuffixOf, nub, partition)
-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 (pgm_c 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
-
-      let merged_specs = mergeStaticObjects cmdline_lib_specs
-      pls1 <- foldM (preloadLib hsc_env lib_paths framework_paths) pls
-                    merged_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
-
--- | Merge runs of consecutive of 'Objects'. This allows for resolution of
--- cyclic symbol references when dynamically linking. Specifically, we link
--- together all of the static objects into a single shared object, avoiding
--- the issue we saw in #13786.
-mergeStaticObjects :: [LibrarySpec] -> [LibrarySpec]
-mergeStaticObjects specs = go [] specs
-  where
-    go :: [FilePath] -> [LibrarySpec] -> [LibrarySpec]
-    go accum (Objects objs : rest) = go (objs ++ accum) rest
-    go accum@(_:_) rest = Objects (reverse accum) : go [] rest
-    go [] (spec:rest) = spec : go [] rest
-    go [] [] = []
-
-{- 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 (Objects [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
-    Objects static_ishs -> do
-      (b, pls1) <- preload_statics lib_paths static_ishs
-      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_statics _paths names
-       = do b <- or <$> mapM doesFileExist names
-            if not b then return (False, pls)
-                     else if dynamicGhc
-                             then  do pls1 <- dynLoadObjs hsc_env pls names
-                                      return (True, pls1)
-                             else  do mapM_ (loadObj hsc_env) names
-                                      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@PersistentLinkerState{..} 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)
-                        ++ concatMap (\lp -> [ Option ("-L" ++ lp)
-                                                    , Option "-Xlinker"
-                                                    , Option "-rpath"
-                                                    , Option "-Xlinker"
-                                                    , Option lp ])
-                                     (nub $ fst <$> temp_sos)
-                        ++ 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
-
-    -- 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 }
-        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.
-
-      -- Code unloading currently disabled due to instability.
-      -- See #16841.
-      -- id False, so that the pattern-match checker doesn't complain
-      | id False -- 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)
-      | otherwise = return () -- see #16841
-
-{- **********************************************************************
-
-                Loading packages
-
-  ********************************************************************* -}
-
-data LibrarySpec
-   = Objects [FilePath] -- Full path names of set of .o files, including trailing .o
-                        -- We allow batched loading to ensure that cyclic symbol
-                        -- references can be resolved (see #13786).
-                        -- 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
-
-instance Outputable LibrarySpec where
-  ppr (Objects objs) = text "Objects" <+> ppr objs
-  ppr (Archive a) = text "Archive" <+> text a
-  ppr (DLL s) = text "DLL" <+> text s
-  ppr (DLLPath f) = text "DLLPath" <+> text f
-  ppr (Framework s) = text "Framework" <+> text s
-
--- 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 (Objects nms)  = "(static) [" ++ intercalate ", " nms ++ "]"
-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 -> UnitInfo -> 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  | Objects objs    <- classifieds
-                                , obj <- objs ]
-            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 -> UnitInfo -> 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 $ Objects . (:[]))  $ findFile dirs obj_file
-     findDynObject = liftM (fmap $ Objects . (:[]))  $ 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
-
-     -- TH Makes use of the interpreter so this failure is not obvious.
-     -- So we are nice and warn/inform users why we fail before we do.
-     -- But only for haskell libraries, as C libraries don't have a
-     -- profiling/non-profiling distinction to begin with.
-     assumeDll
-      | is_hs
-      , not loading_dynamic_hs_libs
-      , interpreterProfiled dflags
-      = do
-          warningMsg dflags
-            (text "Interpreter failed to load profiled static library" <+> text lib <> char '.' $$
-              text " \tTrying dynamic library instead. If this fails try to rebuild" <+>
-              text "libraries with profiling support.")
-          return (DLL lib)
-      | otherwise = return (DLL lib)
-     infixr `orElse`
-     f `orElse` g = f >>= maybe g return
-
-     apply :: [IO (Maybe a)] -> IO (Maybe a)
-     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/LinkerTypes.hs b/compiler/ghci/LinkerTypes.hs
deleted file mode 100644
index 4cdfc198da..0000000000
--- a/compiler/ghci/LinkerTypes.hs
+++ /dev/null
@@ -1,112 +0,0 @@
------------------------------------------------------------------------------
---
--- Types for the Dynamic Linker
---
--- (c) The University of Glasgow 2019
---
------------------------------------------------------------------------------
-
-module LinkerTypes (
-      DynLinker(..),
-      PersistentLinkerState(..),
-      LinkerUnitId,
-      Linkable(..),
-      Unlinked(..),
-      SptEntry(..)
-    ) where
-
-import GhcPrelude              ( FilePath, String, show )
-import Data.Time               ( UTCTime )
-import Data.Maybe              ( Maybe )
-import Control.Concurrent.MVar ( MVar )
-import Module                  ( InstalledUnitId, Module )
-import ByteCodeTypes           ( ItblEnv, CompiledByteCode )
-import Outputable
-import Var                     ( Id )
-import GHC.Fingerprint.Type    ( Fingerprint )
-import NameEnv                 ( NameEnv )
-import Name                    ( Name )
-import GHCi.RemoteTypes        ( ForeignHValue )
-
-type ClosureEnv = NameEnv (Name, ForeignHValue)
-
-newtype DynLinker =
-  DynLinker { dl_mpls :: MVar (Maybe PersistentLinkerState) }
-
-data PersistentLinkerState
-  = PersistentLinkerState {
-
-       -- Current global mapping from Names to their true values
-       closure_env :: ClosureEnv,
-
-       -- The current global mapping from RdrNames of DataCons to
-       -- info table addresses.
-       -- When a new Unlinked is linked into the running image, or an existing
-       -- module in the image is replaced, the itbl_env must be updated
-       -- appropriately.
-       itbl_env    :: !ItblEnv,
-
-       -- The currently loaded interpreted modules (home package)
-       bcos_loaded :: ![Linkable],
-
-       -- And the currently-loaded compiled modules (home package)
-       objs_loaded :: ![Linkable],
-
-       -- The currently-loaded packages; always object code
-       -- Held, as usual, in dependency order; though I am not sure if
-       -- that is really important
-       pkgs_loaded :: ![LinkerUnitId],
-
-       -- we need to remember the name of previous temporary DLL/.so
-       -- libraries so we can link them (see #10322)
-       temp_sos :: ![(FilePath, String)] }
-
--- TODO: Make this type more precise
-type LinkerUnitId = InstalledUnitId
-
--- | Information we can use to dynamically link modules into the compiler
-data Linkable = LM {
-  linkableTime     :: UTCTime,          -- ^ Time at which this linkable was built
-                                        -- (i.e. when the bytecodes were produced,
-                                        --       or the mod date on the files)
-  linkableModule   :: Module,           -- ^ The linkable module itself
-  linkableUnlinked :: [Unlinked]
-    -- ^ Those files and chunks of code we have yet to link.
-    --
-    -- INVARIANT: A valid linkable always has at least one 'Unlinked' item.
-    -- If this list is empty, the Linkable represents a fake linkable, which
-    -- is generated in HscNothing mode to avoid recompiling modules.
-    --
-    -- ToDo: Do items get removed from this list when they get linked?
- }
-
-instance Outputable Linkable where
-  ppr (LM when_made mod unlinkeds)
-     = (text "LinkableM" <+> parens (text (show when_made)) <+> ppr mod)
-       $$ nest 3 (ppr unlinkeds)
-
--- | Objects which have yet to be linked by the compiler
-data Unlinked
-  = DotO FilePath      -- ^ An object file (.o)
-  | DotA FilePath      -- ^ Static archive file (.a)
-  | DotDLL FilePath    -- ^ Dynamically linked library file (.so, .dll, .dylib)
-  | BCOs CompiledByteCode
-         [SptEntry]    -- ^ A byte-code object, lives only in memory. Also
-                       -- carries some static pointer table entries which
-                       -- should be loaded along with the BCOs.
-                       -- See Note [Grant plan for static forms] in
-                       -- StaticPtrTable.
-
-instance Outputable Unlinked where
-  ppr (DotO path)   = text "DotO" <+> text path
-  ppr (DotA path)   = text "DotA" <+> text path
-  ppr (DotDLL path) = text "DotDLL" <+> text path
-  ppr (BCOs bcos spt) = text "BCOs" <+> ppr bcos <+> ppr spt
-
--- | An entry to be inserted into a module's static pointer table.
--- See Note [Grand plan for static forms] in StaticPtrTable.
-data SptEntry = SptEntry Id Fingerprint
-
-instance Outputable SptEntry where
-  ppr (SptEntry id fpr) = ppr id <> colon <+> ppr fpr
-
diff --git a/compiler/ghci/RtClosureInspect.hs b/compiler/ghci/RtClosureInspect.hs
deleted file mode 100644
index 9ed5eaef9f..0000000000
--- a/compiler/ghci/RtClosureInspect.hs
+++ /dev/null
@@ -1,1355 +0,0 @@
-{-# 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 GHC.Types.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 GHC.Iface.Env
-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 GHC.Runtime.Layout ( 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
-          -- GHC.StgToCmm.Layout.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
-              -- GHC.StgToCmm.Layout.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/ghci/keepCAFsForGHCi.c b/compiler/ghci/keepCAFsForGHCi.c
deleted file mode 100644
index ba635b0d95..0000000000
--- a/compiler/ghci/keepCAFsForGHCi.c
+++ /dev/null
@@ -1,15 +0,0 @@
-#include <Rts.h>
-
-// This file is only included in the dynamic library.
-// It contains an __attribute__((constructor)) function (run prior to main())
-// which sets the keepCAFs flag in the RTS, before any Haskell code is run.
-// This is required so that GHCi can use dynamic libraries instead of HSxyz.o
-// files.
-
-static void keepCAFsForGHCi(void) __attribute__((constructor));
-
-static void keepCAFsForGHCi(void)
-{
-    keepCAFs = 1;
-}
-